Programming Languages Suite/ProgramD2.iso/Borland/Borland Pascal with Objects 7.0/WINDEMOS.ZIP/WMENU.PAS

Pascal/Delphi Source File | 1992-10-27 | 5KB | 186 lines

{************************************************}
{                                                }
{   Demo Program                                 }
{   Copyright (c) 1992 by Borland International  }
{                                                }
{************************************************}

program WMenu;

{$R WMenu}

uses WinProcs, WinTypes;

type
  TList = array[1..99] of String[17];

const
  ListCount: Word = 0;

var
  UserMenu: hMenu;
  List: TList;
  MenuName: string[17];
  Window: hWnd;

function AboutProc(Dlg: hWnd; iMessage, wParam: Word; lParam: LongInt): Bool; Export;
begin
  AboutProc := false;
  case iMessage of
    WM_Create: AboutProc:=true;
    WM_Command:
      if (wParam = IDOK) or (wParam = IDCancel) then
      begin
    AboutProc := True;
    EndDialog(Dlg, 0);
      end;
  end;
end;

function CreateProc(Dlg: hWnd; iMessage, wParam: Word; lParam: LongInt): WordBool; export;
var
  Style: Word;
  Name: string[17];
  Found: Boolean;
  I: Integer;
  R: TRect;
begin
  CreateProc:=False;
  case iMessage of
    WM_InitDialog:
      CreateProc := True;
    WM_Command:
      case wParam of
    IDCancel:
          begin
        EndDialog(Dlg, 0);
        CreateProc := True;
      end;
    104:
          begin
        Name[0] := Char(GetWindowText(GetDlgItem(Dlg, 103), @Name[1], 16));
        Found := False;
        for I := 1 to ListCount do
          if Name = List[I] then
          begin
        Found := True;
        DeleteMenu(UserMenu, I+300, MF_ByCommand);
          end;
          if MenuName = Name then
          begin
        MenuName := '';
        GetClientRect(Window, R);
        InvalidateRect(Window, @R, True);
          end;
          if Not found then
        MessageBox(Dlg, 'Item Not Found', 'Error', MB_OK)
          else
        EndDialog(Dlg, 0);
      end;
    IDOK:
          begin
        if SendMessage(GetDlgItem(Dlg, 101), BM_GetCheck, 0,0) = 0 then
          Style := MF_UnChecked
        else
          Style := MF_Checked;
        if SendMessage(GetDlgItem(Dlg, 102), BM_GetCheck, 0,0) = 0 then
          Style := Style or MF_Enabled
        else
          Style := Style or MF_Grayed;
        Name[0]:=Char(GetWindowText(GetDlgItem(Dlg, 103), @Name[1], 16));
        Inc(ListCount);
        if ListCount > 99 then
        begin
          MessageBox(Dlg, 'Too many menus', 'Error', MB_OK);
          Exit;
        end;
        List[ListCount] := Name;
        AppendMenu(UserMenu, Style or MF_String, ListCount+300, @Name[1]);
        EndDialog(Dlg, 0);
        CreateProc := True;
      end;
      end;
  end;
end;

function WindowProc(Wnd: hWnd; iMessage, wParam:Word; lParam: LongInt): LongInt; export;
var
  ProcInst: Pointer;
  DC: hDC;
  PaintStruct: TPaintStruct;
  R: TRect;
begin
  case iMessage of
    WM_Command:
      case WParam of
        100:
          begin
        ProcInst := MakeProcInstance(@CreateProc, hInstance);
        DialogBox(hInstance, 'CreateDlg', Wnd, ProcInst);
        FreeProcInstance(ProcInst);
      end;
        106:
          begin
        ProcInst := MakeProcInstance(@AboutProc, hInstance);
        DialogBox(hInstance, 'About', Wnd, ProcInst);
        FreeProcInstance(ProcInst);
      end;
        301..399:
          begin
        MenuName := List[wParam-300];
        GetClientRect(Window, R);
        InvalidateRect(Window, @R, true);
      end;
        else
      WindowProc:=DefWindowProc(Wnd, iMessage, wParam, lParam);
      end;
      WM_Paint:
        begin
      DC := BeginPaint(Wnd, PaintStruct);
      TextOut(DC, 0, 0, @MenuName[1], Length(MenuName));
      EndPaint(Wnd, PaintStruct);
    end;
      WM_Destroy:
        PostQuitMessage(0);
    else
      WindowProc := DefWindowProc(Wnd, iMessage, wParam, lParam);
  end;
end;

procedure WinMain;
var
  WndClas: TWndClass;
  Msg: TMsg;
begin
  if hPrevInst = 0 then
  begin
    WndClas.Style := 0;
    WndClas.lpfnWndProc:= @WindowProc;
    WndClas.cbClsExtra := 0;
    WndClas.cbWndExtra := 0;
    WndClas.hInstance := HInstance;
    WndClas.hIcon := 0;
    WndClas.hCursor := LoadCursor(0, IDC_Arrow);
    WndClas.hbrBackground := GetStockObject(White_Brush);
    WndClas.lpszMenuName := 'Menu';
    WndClas.lpszClassName := 'GenWindow';
    if not RegisterClass(WndClas) then
      Halt;
  end;
  Window := CreateWindow('GenWindow', 'Menu Example', WS_OverLappedWindow,
    CW_UseDefault, 0, CW_UseDefault, 0, 0, 0, hInstance, nil);
  UpDateWindow(Window);
  UserMenu:=CreatePopUpMenu;
  InsertMenu(GetMenu(Window), 106, MF_ByCommand or MF_PopUp, UserMenu, 'User Define Menu');
  ShowWindow(Window,Sw_ShowNormal);
  while GetMessage(Msg, 0, 0, 0) do
  begin
    TranslateMessage(msg);
    DispatchMessage(msg);
  end;
end;

begin
  WinMain;
end.